home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Intro_to_T2013918162006.psc / Intro to Texture Mapping / basGDI.bas next >
BASIC Source File  |  2006-07-10  |  6KB  |  161 lines
  1. Attribute VB_Name = "basGDI"
  2.  
  3. ' SurfaceGDI
  4. ' By: Hou Xiong
  5. '
  6. ' Simplifies gdi functions.
  7. ' If you decide to include these classes in
  8. ' your projects, please give me some credit.
  9.  
  10. Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  11. Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  12. Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
  13. Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  14. Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  15. Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  16. Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  17. Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  18. Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
  19. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  20. Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
  21. Public Declare Function VarPtrArray Lib "MSVBVM60.dll" Alias "VarPtr" (Ptr() As Any) As Long
  22.  
  23. Public Const LR_LOADFROMFILE = 16
  24.  
  25. Public Type BITMAP
  26.         bmType As Long
  27.         bmWidth As Long
  28.         bmHeight As Long
  29.         bmWidthBytes As Long
  30.         bmPlanes As Integer
  31.         bmBitsPixel As Integer
  32.         bmBits As Long
  33. End Type
  34. Public Type BITMAPINFOHEADER
  35.         biSize As Long
  36.         biWidth As Long
  37.         biHeight As Long
  38.         biPlanes As Integer
  39.         biBitCount As Integer
  40.         biCompression As Long
  41.         biSizeImage As Long
  42.         biXPelsPerMeter As Long
  43.         biYPelsPerMeter As Long
  44.         biClrUsed As Long
  45.         biClrImportant As Long
  46. End Type
  47. Public Type RGBQUAD
  48.         rgbBlue As Byte
  49.         rgbGreen As Byte
  50.         rgbRed As Byte
  51.         rgbReserved As Byte
  52. End Type
  53. Public Type BITMAPINFO
  54.         bmiHeader As BITMAPINFOHEADER
  55.         bmiColors As RGBQUAD
  56. End Type
  57. Public Type SAFEARRAYBOUND
  58.     cElements As Long
  59.     lLbound As Long
  60. End Type
  61. Public Type SAFEARRAY2D
  62.     cDims As Integer
  63.     fFeatures As Integer
  64.     cbElements As Long
  65.     cLocks As Long
  66.     pvData As Long
  67.     Bounds(0 To 1) As SAFEARRAYBOUND
  68. End Type
  69.  
  70. Public Function CreateSurface(ByVal width As Long, ByVal height As Long) As SurfaceGDI
  71.     Set CreateSurface = New SurfaceGDI
  72.     
  73.     With CreateSurface
  74.         Dim hDib As Long
  75.         
  76.         .width = width
  77.         .height = height
  78.         
  79.         Dim bi As BITMAPINFO
  80.         With bi.bmiHeader
  81.             .biSize = LenB(bi)
  82.             .biWidth = width
  83.             .biHeight = -height
  84.             .biPlanes = 1
  85.             .biBitCount = 32
  86.             '.biSizeImage = ((((width * 32) + 31) \ 32) * 4) * height
  87.         End With
  88.         
  89.         .hDC = CreateCompatibleDC(0)
  90.         If .hDC = 0 Then GoTo CreateSurfaceError
  91.         .hBMP = CreateDIBSection(.hDC, bi, 0, hDib, 0, 0)
  92.         If .hBMP = 0 Then GoTo CreateSurfaceError
  93.         If SelectObject(.hDC, .hBMP) = 0 Then GoTo CreateSurfaceError
  94.         If hDib = 0 Then GoTo CreateSurfaceError
  95.         .hDib = hDib
  96.         
  97.         .InitSurface
  98.     End With
  99.     
  100.     Exit Function
  101.     
  102. CreateSurfaceError:
  103. End Function
  104.  
  105. Public Function CreateSurfaceFromFile(ByVal FileName As String) As SurfaceGDI
  106.     Set CreateSurfaceFromFile = New SurfaceGDI
  107.     
  108.     With CreateSurfaceFromFile
  109.         Dim tDC As Long, tBMP As Long, hDib As Long
  110.         
  111.         tDC = CreateCompatibleDC(0)
  112.         If tDC = 0 Then GoTo CreateFromFileError
  113.         tBMP = LoadImage(0, FileName, 0, 0, 0, LR_LOADFROMFILE)
  114.         If tBMP = 0 Then GoTo CreateFromFileError
  115.         SelectObject tDC, tBMP
  116.         
  117.         Dim bmp As BITMAP
  118.         GetObject tBMP, LenB(bmp), bmp
  119.         
  120.         .width = bmp.bmWidth
  121.         .height = bmp.bmHeight
  122.         
  123.         Dim bi As BITMAPINFO
  124.         With bi.bmiHeader
  125.             .biSize = LenB(bi)
  126.             .biWidth = CreateSurfaceFromFile.width
  127.             .biHeight = -CreateSurfaceFromFile.height
  128.             .biPlanes = 1
  129.             .biBitCount = 32
  130.             '.biSizeImage = ((((CreateSurfaceFromFile.width * 32) + 31) \ 32) * 4) * CreateSurfaceFromFile.height
  131.         End With
  132.         
  133.         .hDC = CreateCompatibleDC(0)
  134.         If .hDC = 0 Then GoTo CreateFromFileError
  135.         .hBMP = CreateDIBSection(.hDC, bi, 0, hDib, 0, 0)
  136.         If .hBMP = 0 Then GoTo CreateFromFileError
  137.         SelectObject .hDC, .hBMP
  138.         If hDib = 0 Then GoTo CreateFromFileError
  139.         
  140.         BitBlt .hDC, 0, 0, .width, .height, tDC, 0, 0, vbSrcCopy
  141.         DeleteObject tBMP
  142.         DeleteDC tDC
  143.         
  144.         .hDib = hDib
  145.         
  146.         .InitSurface
  147.     End With
  148.     
  149.     Exit Function
  150.     
  151. CreateFromFileError:
  152. End Function
  153.  
  154. Public Sub EraseLongPointer(Pixels() As Long)
  155.     CopyMemory ByVal VarPtrArray(Pixels()), 0&, 4
  156. End Sub
  157.  
  158. Public Sub EraseRGBPointer(Pixels() As RGBQUAD)
  159.     CopyMemory ByVal VarPtrArray(Pixels()), 0&, 4
  160. End Sub
  161.